perm filename TRISC.F4[SAB,LCS] blob
sn#353912 filedate 1978-05-10 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C PROGRAM TRISC
C00005 ENDMK
Cā;
C PROGRAM TRISC
COMMON X1(5),Y1(5),X2(5),Y2(5),G(1),H(1)
1,X0(5),Y0(5),INK(5),IBUF(5000)
COMMON /FAC/JFAC,KFAC
DATA G/.4/
DATA H/.4/
DATA X0/-.5,-.5,-.7,-.7,-.5/
DATA Y0/.09,-.7,-.7,.09,.09/
DATA X2/-1.,0.0,1.0,-1.,-1./
DATA Y2/1.,0.0,-1.,-1.,1./
DATA INK/3,2,2,2,2/
TYPE 10
ACCEPT 20,JFAC,KFAC
10 FORMAT(' TYPE X FACTOR AND Y FACTOR '$)
20 FORMAT(2I)
CALL PLOTS(IBUF,5000,1)
CALL PLOT(1.,6.,-3)
D=3.
RAD=.5
ANG=15.
DO 1 I=1,42
CC DO 1 I=1,36
IF(I.NE.1)CALL ROTATE(X0,Y0,5,0.,0.,ANG)
RAD1=RAD+R(.3)
DO 50 I1=1,4
X1(I1)=X0(I1)+R(.2)
Y1(I1)=Y0(I1)+R(.2)
50 CONTINUE
X1(5)=X1(1)
Y1(5)=Y1(1)
IF(I.EQ.1)GO TO 100
CALL ROTATE(G,H,1,0.,0.,ANG)
CALL ROTATE(X2,Y2,5,0.,0.,ANG)
100 DO 2 M=1,10
A=(10.-M)/9
DO 3 N=1,5
X=A*X1(N)+(1.-A)*X2(N)
Y=A*Y1(N)+(1.-A)*Y2(N)
CC TYPE 30,X,Y,A
30 FORMAT(3F)
CALL PLOT(X,Y,INK(N))
3 CONTINUE
CALL CIRCL2(RAD1,G,H)
2 CONTINUE
IF(I.EQ.42)GO TO 1
CC IF(I.EQ.36)GO TO 1
CC41 L=MOD(I,6)
41 L=I-6*(I/6)
IF(L.NE.0)CALL PLOT(D,0.,-3)
IF(L.EQ.0)CALL PLOT(0.,2.05,-3)
IF(L.EQ.0)D=-D
CC TYPE 31,D
31 FORMAT(3F)
CC TYPE 21,L
21 FORMAT(3I)
1 CONTINUE
CALL PLOT(0.,-30.,-3)
CALL PLOT(0.,0.,999)
STOP
END
FUNCTION R(Z)
R=2.*Z*(RAN(1.)-.5)
RETURN
END
SUBROUTINE FACTOR(X)
COMMON Z(32)
DO 1 K=1,22
1 Z(K)=Z(K)*X
END